Cream of the Crop 26/Cream of the Crop 26.iso/program/fpkpas92.zip/SRCRTL.ZIP/RTL/DOS/REAL2STR.INC

Text File | 1997-07-01 | 7KB | 234 lines

{****************************************************************************

                   Copyright (c) 1994,96 by Florian Klämpfl

 ****************************************************************************}

  procedure str_real(fixkomma : longint;d : real;var s : string);

    function mod_rr(z,n : real) : real;

      begin
         asm
            fldl n
            fldl z
      Lmod_rr1:
            fprem
            fstsw %ax
            sahf
            jp Lmod_rr1

            fstpl __result
            { remove n from stack }
            fstpl n
         end;
      end;

    const
       maxexponent = 309;
       maxfract = 16;

    var
       buffer : array[0..maxexponent+maxfract+1] of char;
       sign : char;
       p : pchar;
       defprec,pos,i,exponent,aktprec : longint;
       fracfrag,intrest : real;
       hs : string;
       cut : boolean;

    begin
       defprec:=maxfract;
       if fixkomma>maxfract then
         fixkomma:=maxfract;
       if d<0 then
         begin
            sign:='-';
            d:=abs(d);
         end
       else
         sign:='+';
       p:=@buffer[maxexponent+maxfract+1];
       fracfrag:=frac(d);

       { Vorkommastellen abspalten }
       intrest:=int(d);
       exponent:=0;
       aktprec:=0;
       while intrest>0 do
         begin
            { Attention: this works only for numbers =< 2^31
              p^:=chr(trunc(intrest) mod 10.0)+ord('0'));
            }
            p^:=chr(trunc(mod_rr(intrest,10.0))+ord('0'));
            intrest:=int(intrest/10.0);
            p:=p-1;
            inc(exponent);
            inc(aktprec);
         end;
       p:=p+1;
       for i:=0 to exponent do
         begin
            buffer[i]:=p^;
            p:=p+1;
         end;

       { cut seamless digits }
       if aktprec>maxfract then
         aktprec:=maxfract;

       { if we need more precision, calculate more digits }
       pos:=exponent;
       if exponent=0 then
         cut:=true
       else cut:=false;

       { calculate the digits after the comma }

       { +2 because the while condition is aktprec<defprec and we need }
       { one digit to round                                            }
       if fixkomma>=0 then
         defprec:=aktprec+fixkomma+2;

       { we can't calulate an infinity precision! }
       if defprec>maxfract then
         defprec:=maxfract;

       while aktprec<defprec do
         begin
            fracfrag:=fracfrag*10;
            { sollte der Nachkommateil gleich 0 sein, dann mit 0en auffüllen }
            if fracfrag=0 then
              begin
                 for i:=aktprec to defprec-1 do
                   begin
                      buffer[pos]:='0';
                      inc(aktprec);
                      inc(pos);
                   end;
                 break;
              end;
            buffer[pos]:=chr(trunc(fracfrag)+ord('0'));

            { cut leading zeros }
            if (buffer[pos]='0') and (cut) then
              dec(exponent)
            else
              begin
                 cut:=false;
                 inc(aktprec);
                 inc(pos);
              end;
            fracfrag:=frac(fracfrag);
         end;
       dec(aktprec);

       buffer[pos]:=#0;
       if ord(buffer[aktprec])>=ord('5') then
         begin
            { Stelle davor 9 ? }
            if buffer[aktprec-1]='9' then
              begin
                 { alle 9en aufrunden }
                 i:=1;
                 while buffer[aktprec-i]='9' do
                   begin
                      buffer[aktprec-i]:='0';
                      inc(i);
                      if i>aktprec then
                        break;
                   end;
                 { 9.9999999eX wird zu 1e(X+1) gerundet }
                 if i>aktprec then
                   begin
                      buffer[0]:='1';
                      inc(exponent);
                   end
                 else
                   buffer[aktprec-i]:=chr(ord(buffer[aktprec-i])+1);
              end
            else buffer[aktprec-1]:=chr(ord(buffer[aktprec-1])+1);
            buffer[aktprec]:=#0;
         end;
       if sign='-' then
         s:='-'
       else
         begin
            if fixkomma>=0 then
              s:=''
            else
              s:=' ';
         end;
       { fixkomma used and fixkomma possible ? }
       if (fixkomma>=0) then
         begin
            { need we a comma ? }
            if exponent<=0 then
              begin
                 s:=s+'0';
                 if fixkomma>0 then
                   s:=s+'.';

                 { insert zeros, after the comma }
                 if fixkomma>0 then
                   begin
                      for i:=-1 downto exponent do
                        begin
                           s:=s+'0';
                           dec(aktprec);
                           dec(fixkomma);
                           if fixkomma=0 then
                             break;
                        end;
                   end;
              end;
            p:=@buffer[0];
            while (fixkomma>0) and (aktprec>0) do
              begin
                 s:=s+p^;
                 p:=p+1;
                 dec(aktprec);
                 dec(exponent);
                 if (p^=#0) or (aktprec=0) then
                   begin
                      { fill with zero }
                      for i:=1 to exponent do
                        s:=s+'0';
                      if exponent>=1 then
                        s:=s+'.';
                      for i:=1 to fixkomma do
                        s:=s+'0';
                      break;
                   end;
                 if exponent<0 then
                   dec(fixkomma)
                 else if (exponent=0) then
                   begin
                      { no comma digits ? }
                      if fixkomma=0 then
                         break;
                      s:=s+'.'
                   end;
              end;
         end
       else
         begin
            s:=s+buffer[0]+'.';
            p:=@buffer[1];
            while (p^<>#0) and (aktprec>1) do
              begin
                 s:=s+p^;
                 p:=p+1;
                 dec(aktprec);
              end;
            dec(exponent);
            if exponent<0 then
              sign:='-'
            else sign:='+';
            str(abs(exponent),hs);
            while length(hs)<4 do
              hs:='0'+hs;
            s:=s+'E'+sign+hs;
         end;
    end;